{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-# OPTIONS_GHC -Wno-unused-imports #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}
{-# OPTIONS_GHC -Wno-unused-matches #-}

module Cardano.TxSubmit.Web
  ( runTxSubmitServer
  ) where

import           Cardano.Api (AllegraEra, AnyCardanoEra (AnyCardanoEra), AsType (..),
                   CardanoEra (..), ConsensusModeParams (..), Error (..), FromSomeType (..),
                   HasTypeProxy (AsType), InAnyCardanoEra (..), InAnyShelleyBasedEra (..),
                   IsCardanoEra (..),
                   LocalNodeConnectInfo (LocalNodeConnectInfo, localConsensusModeParams, localNodeNetworkId, localNodeSocketPath),
                   NetworkId, SerialiseAsCBOR (..), ShelleyBasedEra (..), ShelleyEra, SocketPath,
                   ToJSON, Tx, TxId (..), TxInMode (TxInMode), TxValidationErrorInCardanoMode (..),
                   getTxBody, getTxId, submitTxToNodeLocal)

import           Cardano.Binary (DecoderError (..))
import           Cardano.BM.Trace (Trace, logInfo)
import qualified Cardano.Crypto.Hash.Class as Crypto
import           Cardano.TxSubmit.Metrics (TxSubmitMetrics (..))
import           Cardano.TxSubmit.Rest.Types (WebserverConfig (..), toWarpSettings)
import qualified Cardano.TxSubmit.Rest.Web as Web
import           Cardano.TxSubmit.Types (EnvSocketError (..), RawCborDecodeError (..),
                   TxCmdError (..), TxSubmitApi, TxSubmitApiRecord (..),
                   TxSubmitWebApiError (TxSubmitFail), renderTxCmdError)
import           Cardano.TxSubmit.Util (logException)
import           Ouroboros.Consensus.Cardano.Block (EraMismatch (..))
import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Client as Net.Tx

import           Control.Applicative (Applicative (pure), (<$>))
import           Control.Monad (Functor (fmap), Monad (return), (=<<))
import           Control.Monad.Except (ExceptT, MonadError (throwError), runExceptT)
import           Control.Monad.IO.Class (MonadIO (liftIO), liftIO)
import           Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither,
                   hoistMaybe, left, newExceptT)
import           Data.Aeson (ToJSON (..))
import qualified Data.Aeson as Aeson
import           Data.Bifunctor (first, second)
import qualified Data.ByteString as BS
import           Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B8
import qualified Data.Char as Char
import           Data.Either (Either (..), partitionEithers)
import           Data.Function (($), (.))
import qualified Data.List as L
import qualified Data.List.NonEmpty as NEL
import           Data.Maybe (listToMaybe, maybe)
import           Data.Proxy (Proxy (..))
import           Data.Semigroup (Semigroup ((<>)))
import           Data.String (String)
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import           System.Environment (lookupEnv)
import qualified System.IO as IO
import           System.IO (IO)
import qualified System.Metrics.Prometheus.Metric.Gauge as Gauge
import           Text.Show (Show (show))

import qualified Servant
import           Servant (Application, Handler, ServerError (..), err400, throwError)
import           Servant.API.Generic (toServant)
import           Servant.Server.Generic (AsServerT)

runTxSubmitServer
  :: Trace IO Text
  -> TxSubmitMetrics
  -> WebserverConfig
  -> ConsensusModeParams
  -> NetworkId
  -> SocketPath
  -> IO ()
runTxSubmitServer trace metrics webserverConfig protocol networkId socketPath = do
  logException trace "TxSubmit WebAPI: " $
    Web.runSettings trace (toWarpSettings webserverConfig) $ txSubmitApp trace metrics protocol networkId socketPath
  logInfo trace "txSubmitApp: exiting"

txSubmitApp
  :: Trace IO Text
  -> TxSubmitMetrics
  -> ConsensusModeParams
  -> NetworkId
  -> SocketPath
  -> Application
txSubmitApp trace metrics connectInfo networkId socketPath =
    Servant.serve (Proxy :: Proxy TxSubmitApi) (toServant handlers)
  where
    handlers :: TxSubmitApiRecord (AsServerT Handler)
    handlers = TxSubmitApiRecord
      { _txSubmitPost = txSubmitPost trace metrics connectInfo networkId socketPath
      }

deserialiseOne :: forall b. ()
  => FromSomeType SerialiseAsCBOR b
  -> ByteString
  -> Either DecoderError b
deserialiseOne (FromSomeType ttoken f) bs = f <$> deserialiseFromCBOR ttoken bs

deserialiseAnyOf :: forall b. ()
  => [FromSomeType SerialiseAsCBOR b]
  -> ByteString
  -> Either RawCborDecodeError b
deserialiseAnyOf ts te = getResult . partitionEithers $ fmap (`deserialiseOne` te) ts
  where
    getResult :: ([DecoderError], [b]) -> Either RawCborDecodeError b
    getResult (dErrors, []) = Left $ RawCborDecodeError dErrors
    getResult (_, result:_) = Right result -- take the first successful decode

readByteStringTx :: ByteString -> ExceptT TxCmdError IO (InAnyShelleyBasedEra Tx)
readByteStringTx = firstExceptT TxCmdTxReadError . hoistEither . deserialiseAnyOf
  [ FromSomeType (AsTx AsShelleyEra) (InAnyShelleyBasedEra ShelleyBasedEraShelley)
  , FromSomeType (AsTx AsAllegraEra) (InAnyShelleyBasedEra ShelleyBasedEraAllegra)
  , FromSomeType (AsTx AsMaryEra)    (InAnyShelleyBasedEra ShelleyBasedEraMary)
  , FromSomeType (AsTx AsAlonzoEra)  (InAnyShelleyBasedEra ShelleyBasedEraAlonzo)
  , FromSomeType (AsTx AsBabbageEra) (InAnyShelleyBasedEra ShelleyBasedEraBabbage)
  , FromSomeType (AsTx AsConwayEra)  (InAnyShelleyBasedEra ShelleyBasedEraConway)
  ]

txSubmitPost
  :: Trace IO Text
  -> TxSubmitMetrics
  -> ConsensusModeParams
  -> NetworkId
  -> SocketPath
  -> ByteString
  -> Handler TxId
txSubmitPost trace metrics p@(CardanoModeParams cModeParams) networkId socketPath txBytes =
  handle $ do
    InAnyShelleyBasedEra sbe tx <- readByteStringTx txBytes
    let txInMode = TxInMode sbe tx
        localNodeConnInfo = LocalNodeConnectInfo
                              { localConsensusModeParams = p
                              , localNodeNetworkId = networkId
                              , localNodeSocketPath = socketPath
                              }

    res <- liftIO $ submitTxToNodeLocal localNodeConnInfo txInMode
    case res of
      Net.Tx.SubmitSuccess -> do
        liftIO $ T.putStrLn "Transaction successfully submitted."
        return $ getTxId (getTxBody tx)
      Net.Tx.SubmitFail e ->
        left $ TxCmdTxSubmitValidationError e
    where
      handle :: ExceptT TxCmdError IO TxId -> Handler TxId
      handle f = do
        result <- liftIO $ runExceptT f
        handleSubmitResult result

      errorResponse :: ToJSON e => e -> Handler a
      errorResponse e = throwError $ err400 { errBody = Aeson.encode e }

      -- Log relevant information, update the metrics, and return the result to
      -- the client.
      handleSubmitResult :: Either TxCmdError TxId -> Handler TxId
      handleSubmitResult res =
        case res of
          Left err -> do
            liftIO $ logInfo trace $
              "txSubmitPost: failed to submit transaction: "
                <> renderTxCmdError err
            liftIO $ Gauge.inc (tsmFailCount metrics)
            errorResponse (TxSubmitFail err)
          Right txid -> do
            liftIO $ logInfo trace $
              "txSubmitPost: successfully submitted transaction "
                <> renderMediumTxId txid
            liftIO $ Gauge.inc (tsmCount metrics)
            pure txid

-- | Render the first 16 characters of a transaction ID.
renderMediumTxId :: TxId -> Text
renderMediumTxId (TxId hash) = renderMediumHash hash

-- | Render the first 16 characters of a hex-encoded hash.
renderMediumHash :: Crypto.Hash crypto a -> Text
renderMediumHash = T.take 16 . T.decodeLatin1 . Crypto.hashToBytesAsHex
